Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/accrd1/board.frm

Text File | 1995-05-08 | 6KB | 246 lines

VERSION 2.00
Begin Form Form1
   BackColor       =   &H0000C000&
   Caption         =   "Accordian"
   ClientHeight    =   4605
   ClientLeft      =   855
   ClientTop       =   1515
   ClientWidth     =   7875
   Height          =   5295
   Icon            =   BOARD.FRX:0000
   Left            =   795
   LinkMode        =   1  'Source
   LinkTopic       =   "Form1"
   ScaleHeight     =   4605
   ScaleWidth      =   7875
   Top             =   885
   Width           =   7995
   Begin CommandButton Command1
      Caption         =   "Deal"
      Default         =   -1  'True
      Height          =   1215
      Left            =   6000
      TabIndex        =   1
      Top             =   240
      Width           =   1695
   End
   Begin PictureBox Picture1
      AutoSize        =   -1  'True
      BackColor       =   &H00FFFFFF&
      BorderStyle     =   0  'None
      DragMode        =   1  'Automatic
      Height          =   1455
      Index           =   0
      Left            =   120
      ScaleHeight     =   1455
      ScaleWidth      =   1095
      TabIndex        =   0
      Top             =   120
      Width           =   1095
   End
   Begin Menu GameMenu
      Caption         =   "&Game"
      Begin Menu GameNew
         Caption         =   "&New Game"
         Shortcut        =   {F2}
      End
      Begin Menu GameUndo
         Caption         =   "&Undo"
         Shortcut        =   ^H
      End
      Begin Menu GameRecord
         Caption         =   "&Record of Games"
      End
      Begin Menu GameBar
         Caption         =   "-"
      End
      Begin Menu GameExit
         Caption         =   "E&xit"
      End
   End
   Begin Menu OptionMenu
      Caption         =   "&Options"
      Begin Menu OptionsErrors
         Caption         =   "Display Errors"
         Checked         =   -1  'True
      End
      Begin Menu OptionsCompressed
         Caption         =   "Compressed"
         Shortcut        =   {F5}
      End
   End
   Begin Menu HelpMenu
      Caption         =   "Help"
      Begin Menu HelpIndex
         Caption         =   "Index"
         Shortcut        =   {F1}
      End
      Begin Menu HelpAbout
         Caption         =   "&About"
      End
   End
End
DefInt A-Z

Sub Command1_Click ()

   UndoSave'Save current state

   Piles = Piles + 1
   i = Piles - 1

   Load Picture1(i)
   table(Piles) = cards(NextCard)
   GetCard (cards(NextCard))
   Picture1(i).Picture = ClipBoard.GetData(2)
   Picture1(i).Top = CurrentRow(Piles)
   Picture1(i).Left = CurrentCol(Piles)
   Picture1(i).Visible = -1

   NextCard = NextCard + 1
   If NextCard = 53 Then
     Command1.Enabled = 0
   End If
End Sub

Sub Form_Load ()
   If CardVersion() <> 101 Then
      MsgBox Appname$ + " requires VBCARDS.DLL Version 1.01P", 48, "Version Error!"
      End
   End If
   Undone = -1
   Piles = 1

   OptionsErrors.Checked = DisplayError
   OptionsCompressed.Checked = Compressed

   ShuffleCards

   GetCard (cards(1))
   table(1) = cards(1)
   Picture1(0).Picture = ClipBoard.GetData(2)

   NextCard = 2
End Sub






Sub GameExit_Click ()
   UpdateIni
   End
End Sub

Sub GameNew_Click ()
    NewGame
End Sub

Sub GameRecord_Click ()
   S$ = "Total Games is " + Str$(GamesWon + GamesLost) + Chr$(13) + Chr$(10)
   S$ = S$ + "Games Won  = " + Str$(GamesWon) + Chr$(13) + Chr$(10)
   S$ = S$ + "Games Lost = " + Str$(GamesLost)
   MsgBox S$, 0, "Record of Games"
End Sub

Sub GameUndo_Click ()
    If Undone = 0 Then

       'Expand or Decrease the size of the table
       If UndoPiles > Piles Then
          Load Picture1(Piles)
          Picture1(Piles).Top = CurrentRow(UndoPiles)
          Picture1(Piles).Left = CurrentCol(UndoPiles)
          Picture1(Piles).Visible = -1
       Else
          Unload Picture1(Piles - 1)
       End If

       For i = 1 To UndoPiles
          table(i) = Undoer(i)
          GetCard (Undoer(i))
          Picture1(i - 1).Picture = ClipBoard.GetData(2)
       Next

       Piles = UndoPiles
       NextCard = UndoNextCard
       Undone = -1
    Else
       Beep
    End If
End Sub

Sub HelpAbout_Click ()
   Form3.Show 1
End Sub

Sub HelpIndex_Click ()
   X = Shell("WinHelp E:\VB\Card1\Accord.hlp", 1)
End Sub

Sub OptionsCompressed_Click ()
    Compressed = Not Compressed
    OptionsCompressed.Checked = Compressed
    For i = 1 To Piles
       GetCard (table(i))
       Picture1(i - 1).Picture = ClipBoard.GetData(2)
       Picture1(i - 1).Top = CurrentRow(i)
    Next
    Form1.Refresh
End Sub

Sub OptionsErrors_Click ()
    DisplayError = Not DisplayError
    OptionsErrors.Checked = DisplayError
End Sub

Sub Picture1_DblClick (Index As Integer)
   If Index = 0 Then
     Beep
   Else
     If ValidMove(Index, Index - 1) Then
       UndoSave
       Picture1(Index - 1).Picture = Picture1(Index).Picture
       table(Index) = table(Index + 1)
       Compact (Index)
     Else
       If Index > 2 Then
         If ValidMove(Index, Index - 3) Then
            UndoSave
            Picture1(Index - 3).Picture = Picture1(Index).Picture
            table(Index - 2) = table(Index + 1)
            Compact (Index)
          Else
            Beep
          End If
       Else
          Beep
       End If
     End If
   End If
End Sub

Sub Picture1_DragDrop (Index As Integer, Source As Control, X As Single, Y As Single)
   If Source.Index = Index Then
     Exit Sub
   End If

   i% = Source.Index - Index
   If Source.Index < Index Then
      ShowError ("You must move cards towards the top")
   ElseIf (i% <> 1) And (i% <> 3) Then
      ShowError ("Card must be next to, or 4 away from target")
   Else
     If ValidMove(Source.Index, Index) Then
       UndoSave
       Picture1(Index).Picture = Source.Picture
       table(Index + 1) = table(Source.Index + 1)
       Compact (Source.Index)
     Else
       ShowError ("Card must be same suit or same value")
     End If
 End If
End Sub